;;; support-code.scm
;;; Part of the initial environment that you will need to provide with your
;;; compiler, but written in [very elementary] Scheme. Put otherwise, your
;;; compiler will have to be able to compile this code in order to provide it.

;;; Programmer: Mayer Goldberg, 2009

;;; Use this procedure for boxing your variables
;;; when removing set! during the semantic analysis
(define box (lambda (x)
	(let
		((v (make-vector 1)))

		(vector-set! v 0 x)
		v
	)
))

(define null? (lambda (x) (eq? () x)))

(define foldr (lambda (binop final s)
	(letrec
		((loop (lambda (s)
			(if (null? s)
				final
				(binop (car s) (loop (cdr s)))
			)
		)))
		(loop s)
	)
))

(define add1 (lambda (n) (binary-add n 1)))
(define sub1 (lambda (n) (binary-sub n 1)))

(define order (lambda (<)
	(letrec
		((loop (lambda (a s)
			(or
				(null? s)
				(and
					(< a (car s))
					(loop (car s) (cdr s))
				)
			)
		)))

		(lambda (a . s)
			(loop a s)
		)
	)
))

(define < (order binary<?))

(define <=
	(let
		((binary<=? (lambda (a b)
			(or (binary<? a b) (binary=? a b))
		)))
		(order binary<=?)
	)
)

(define binary>? (lambda (a b) (binary<? b a)))

(define > (order binary>?))

(define >=
	(let
		((binary>=? (lambda (a b)
			(or (binary=? a b) (binary>? a b))
		)))
		(order binary>=?)
	)
)

(define = (order binary=?))

;;; extension: a variadic not-equal
(define <>
	(letrec
		((loop (lambda (a s)
			(or (null? s)
			(and
				(andmap (lambda (b) (not (= a b))) s)
				(loop (car s) (cdr s)))))
		))
		(lambda s
			(loop (car s) (cdr s))
		)
	)
)

(define not (lambda (x) (if x #f #t)))

(define compose
	(let
		((binary-compose
			(lambda (f g)
				(lambda (x)
					(f (g x))))
		))
		(lambda s
			(foldr binary-compose (lambda (x) x) s)
		)
	)
)

(define length (lambda (s)
	(if (null? s)
		0
		(add1 (length (cdr s)))
	)
))

(define caar (compose car car))
(define cadr (compose car cdr))
(define cdar (compose cdr car))
(define cddr (compose cdr cdr))
(define caaar (compose car caar))
(define caadr (compose car cadr))
(define cadar (compose car cdar))
(define caddr (compose car cddr))
(define cdaar (compose cdr caar))
(define cdadr (compose cdr cadr))
(define cddar (compose cdr cdar))
(define cdddr (compose cdr cddr))
(define caaaar (compose car caaar))
(define caaadr (compose car caadr))
(define caadar (compose car cadar))
(define caaddr (compose car caddr))
(define cadaar (compose car cdaar))
(define cadadr (compose car cdadr))
(define caddar (compose car cddar))
(define cadddr (compose car cdddr))
(define cdaaar (compose cdr caaar))
(define cdaadr (compose cdr caadr))
(define cdadar (compose cdr cadar))
(define cdaddr (compose cdr caddr))
(define cddaar (compose cdr cdaar))
(define cddadr (compose cdr cdadr))
(define cdddar (compose cdr cddar))
(define cddddr (compose cdr cdddr))

(define ^variadic-right-from-binary (lambda (binary-op base-value)
	(letrec
		((op-list (lambda (s)
			(if (null? s)
				base-value
				(binary-op (car s) (op-list (cdr s)))
			)
		)))
		(lambda args
			(op-list args)
		)
	)
))

(define ^variadic-left-from-binary (lambda (binary-op base-value)
	(letrec
		((op-list (lambda (acc s)
			(if (null? s) acc
				(op-list (binary-op acc (car s)) (cdr s))
			)
		)))

		(lambda args
			(cond
				((null? args) base-value)
				((= (length args) 1) (binary-op base-value (car args)))
				((op-list (car args) (cdr args)))
			)
		)
	)
))

(define + (^variadic-right-from-binary binary-add 0))
(define * (^variadic-right-from-binary binary-mul 1))

(define - (^variadic-left-from-binary binary-sub 0))
(define / (^variadic-left-from-binary binary-div 1))

(define ^char-op (lambda (int-op)
	(lambda (ch1 ch2)
		(int-op (char->integer ch1) (char->integer ch2))
	)
))

(define char=? (lambda (chr1 chr2) (= (char->integer chr1) (char->integer chr2))))

(define char<=? (order (^char-op <=)))
(define char<? (order (^char-op <)))
(define char>=? (order (^char-op >=)))
(define char>? (order (^char-op >)))

(define char-uppercase? (lambda (ch)
	(and (char<=? #\A ch) (char<=? ch #\Z))
))

(define char-lowercase? (lambda (ch)
	(and (char<=? #\a ch) (char<=? ch #\z))
))

(define char-upcase
	(let
		((char-aA (- (char->integer #\a) (char->integer #\A))))

		(lambda (ch)
			(if (char-lowercase? ch)
				(integer->char (- (char->integer ch) char-aA))
				ch
			)
		)
	)
)

(define char-downcase
	(let ((char-aA (- (char->integer #\a) (char->integer #\A))))
		(lambda (ch)
			(if (char-uppercase? ch)
				(integer->char (+ (char->integer ch) char-aA))
				ch
			)
		)
	)
)

(define char-ci<=?
	(order
		(lambda (ch1 ch2)
			(char<=? (char-upcase ch1) (char-upcase ch2))
		)
	)
)

(define char-ci<?
	(order
		(lambda (ch1 ch2)
			(char<? (char-upcase ch1) (char-upcase ch2))
		)
	)
)

(define char-ci=?
	(order
		(lambda (ch1 ch2)
			(char=? (char-upcase ch1) (char-upcase ch2))
		)
	)
)

(define char-ci>?
	(order
		(lambda (ch1 ch2)
			(char>? (char-upcase ch1) (char-upcase ch2))
		)
	)
)

(define char-ci>=?
	(order
		(lambda (ch1 ch2)
			(char>=? (char-upcase ch1) (char-upcase ch2))
		)
	)
)

(define string-upcase (lambda (string)
	(list->string (map char-upcase (string->list string)))
))

(define string-downcase	(lambda (string)
	(list->string
		(map char-downcase (string->list string))
	)
))

(define even? (lambda (n) (zero? (remainder n 2))))

(define odd? (lambda (n) (not (zero? (remainder n 2)))))

(define list (lambda args args))

(define list-ref (lambda (s i)
	(if (zero? i)
		(car s)
		(list-ref (cdr s) (- i 1))
	)
))

(define list? (lambda (e)
	(or
		(null? e)
		(and (pair? e) (list? (cdr e)))
	)
))

(define map
	(letrec
		(
			(map-list (lambda (f lists)
					(if (null? (car lists))
						'()
						(cons
							(apply f (map-one car lists))
							(map-list f (map-one cdr lists))
						)
					)
			))
			(map-one (lambda (f s)
					(if (null? s)
						'()
						(cons
							(f (car s))
							(map-one f (cdr s))
						)
					)
			))
		)
		(lambda (f . args)
			(map-list f args)
		)
	)
)

(define member? (lambda (a s)
	(ormap (lambda (b) (equal? a b)) s)
))

(define negative? (lambda (n) (< n 0)))
(define positive? (lambda (n) (> n 0)))
(define zero? (lambda (x) (= x 0)))
(define number? integer?)

(define vector (lambda args (list->vector args)))

(define ormap (lambda (f s)
	(and
		(pair? s)
		(or
			(f (car s))
			(ormap f (cdr s))
		)
	)
))

(define andmap (lambda (f s)
	(or
		(null? s)
		(and
			(f (car s))
			(andmap f (cdr s))
		)
	)
))

(define string->list
	(letrec
		((loop (lambda (str n s)
			(if (= n -1)
				s
				(loop
					str
					(- n 1)
					(cons (string-ref str n) s)
				)
			)
		)))
		(lambda (str)
			(loop
				str
				(- (string-length str) 1)
				'()
			)
		)
	)
)

(define binary-string=? (lambda (str1 str2)
	(let
		(
			(n1 (string-length str1))
			(n2 (string-length str2))
		)
		(and
			(= n1 n2)
			(let
				(
					(s1 (string->list str1))
					(s2 (string->list str2))
				)
				(map char=? s1 s2)
			)
		)
	)
))

(define binary-string<? (lambda (str1 str2)
	(letrec
		((loop (lambda (s1 s2)
					(cond
						((null? s1) (pair? s2))
						((null? s2) #f)
						((char=? (car s1) (car s2)) (loop (cdr s1) (cdr s2)))
						(else (char<? (car s1) (car s2))))
		)))
		(loop (string->list str1) (string->list str2))
	)
))

(define binary-string>? (lambda (str1 str2) (binary-string<? str2 str1)))

(define binary-string<=? (lambda (str1 str2)
	(not (binary-string>? str1 str2))
))

(define binary-string>=? (lambda (str1 str2)
	(not (binary-string<? str1 str2))
))

(define string=? (order binary-string=?))
(define string<? (order binary-string<?))
(define string>? (order binary-string>?))
(define string<=? (order binary-string<=?))
(define string>=? (order binary-string>=?))

(define vector->list
	(letrec
		((loop (lambda (v n s)
			(if (= n -1)
				s
				(loop
					v
					(- n 1)
					(cons (vector-ref v n) s)
				)
			)
		)))
		(lambda (v)
			(loop
				v
				(- (vector-length v) 1)
				'()
			)
		)
	)
)

(define list->string (lambda (s)
	(let*
		(
			(n (length s))
			(str (make-string n))
		)
		(letrec
			((loop (lambda (s i)
				(if (= i n)
					str
					(begin
						(string-set! str i (car s))
						(loop (cdr s) (+ i 1))
					)
				)
			)))

			(loop s 0)
		)
	)
))

(define list->vector (lambda (s)
	(let*
		(
			(n (length s))
			(v (make-vector n))
		)
		(letrec
			((loop (lambda (s i)
				(if (= i n)
					v
					(begin
						(vector-set! v i (car s))
						(loop (cdr s) (+ i 1))
					)
				)
			)))
			(loop s 0)
		)
	)
))

(define member (lambda (a s)
	(cond
		((null? s) #f)
		((equal? (car s) a) s)
		(else (member a (cdr s)))
	)
))

(define assoc (lambda (a s)
	(cond
		((null? s) #f)
		((eq? (caar s) a) (car s))
		(else (assoc a (cdr s)))
	)
))

(define equal? (lambda (e1 e2)
	(cond
		((and (pair? e1) (pair? e2))
			(and (equal? (car e1) (car e2)) (equal? (cdr e1) (cdr e2))))
		((and (vector? e1) (vector? e2) (= (vector-length e1) (vector-length e2)))
			(equal? (vector->list e1) (vector->list e2)))
		((and (null? e1) (null? e2)) #t)
		((and (boolean? e1) (boolean? e2)) 	(or (and e1 e2) (and (not e1) (not e2))))
		((and (char? e1) (char? e2)) (char=? e1 e2))
		((and (number? e1) (number? e2)) (= e1 e2))
		((and (string? e1) (string? e2)) (string=? e1 e2))
		((and (symbol? e1) (symbol? e2)) (eq? e1 e2))
		((and (void? e1) (void? e2)) #t)
		(else #f)
	)
))

(define void
	(let
		((void-object (if #f #f)))
		(lambda () void-object)
	)
)

(define void?
	(let
		((void-object (void)))
    	(lambda (x) (eq? x void-object))
	)
)

(define string-append (lambda s
	(list->string (apply append (map string->list s)))
))

(define vector-append (lambda s
	(list->vector (apply append (map vector->list s)))
))

(define append
	(letrec
		((binary-append (lambda (s1 s2)
			(if (null? s1)
				s2
				(cons
					(car s1)
					(binary-append (cdr s1) s2)
				)
			)
		)))
		(lambda s
			(foldr binary-append '() s)
		)
	)
)

(define reverse
	(letrec
		((loop (lambda (s r)
			(if (null? s)
				r
				(loop
					(cdr s)
					(cons (car s) r)
				)
			)
		)))
		(lambda (s)
			(loop s '())
		)
	)
)

(define string-reverse (compose list->string reverse string->list))

(define list-ref (lambda (s i)
	(if (zero? i)
		(car s)
		(list-ref (cdr s) (- i 1))
	)
))

(define list-set! (lambda (s i x)
	(if (zero? i)
		(set-car! s x)
		(list-set! (cdr s) (- i 1) x)
	)
))

(define max
	(let
		((binary-max (lambda (a b) (if (> a b) a b))))
		(lambda (a . s)
			(foldr binary-max a s)
		)
	)
)

(define min
	(let
		((binary-min (lambda (a b) (if (< a b) a b))))
		(lambda (a . s)
			(foldr binary-min a s)
		)
	)
)

(define sgn (lambda (x)
	(cond
		((positive? x) 1)
		((negative? x) -1)
		(else 0)
	)
))
(define abs (lambda (x) (binary-mul x (sgn x))))

(define remainder (lambda (m n)
	(let
		(
			(abs-m (abs m))
			(abs-n (abs n))
			(sgn-m (sgn m))
		)
		(binary-mul
			sgn-m
			(binary-sub
				abs-m
				(binary-mul (binary-div abs-m abs-n) abs-n) ; (m/n)*n, in integers
			)
		)
	)
))

(define gcd
	(letrec
		((binary-gcd (lambda (a b)
			(if (zero? b)
				a
				(let
					((r (remainder a b)))
					(if (zero? r)
						b
						(binary-gcd b r)
					)
				)
			)
		)))
		(lambda (a . s)
			(foldr binary-gcd a s)
		)
	)
)

(define lcm
	(lambda s
		(/
			(apply * s)
			(apply gcd s)
		)
	)
)
